Software Vault: The Gold Collection/Software Vault - The Gold Collection (American Databankers) (1993).ISO/cdr05/mswlogo3.zip/MSWLOGO.ZIP/EXAMPLES.ZIP/FSM

Text File | 1993-04-12 | 8KB | 329 lines

;
; Function:
;
; Finite State Machine Parser. See "MACH1-MACH10 at bottom"
;
; To run:
;
; Load "fsm
; Call GAME machinenumber
; Now enter character sequences that are legal for the machine
;
; Example:
;
; GAME 1
; aaaabbabababa (ACCEPTED)
; ababababababac (REJECTED, because "c" is not legal for machine 1)
;
TO ACCEPT
LOCAL "OLDPOS
MAKE "OLDPOS CURSOR
SETCURSOR [15 1]
TYPE "ACCEPT
SETCURSOR :OLDPOS
END

TO ACCEPTPART :MACHINE
OP LAST :MACHINE
END

TO ARRANGE :MOVE
LOCAL [FROM INPUT TO ARROW]
MAKE "FROM FIRST :MOVE
MAKE "INPUT FIRST BF :MOVE
MAKE "TO LAST :MOVE
MAKESTATE :FROM
MAKESTATE :TO
MAKE "ARROW WORD :FROM :INPUT
IFELSE NAMEP :ARROW [ARRANGE.DUPLICATE :ARROW] [ARRANGE.UNSEEN :ARROW]
END

TO ARRANGE.DUPLICATE :ARROW
IF MEMBERP :TO THING :ARROW [STOP]
MAKE "TROUBLE "TRUE
MAKE :ARROW MERGE :TO THING :ARROW
END

TO ARRANGE.UNSEEN :ARROW
MAKE :FROM FPUT :INPUT THING :FROM
TEMPMAKE :ARROW SINGLE :TO
END

TO BLANK
LOCAL "OLDPOS
MAKE "OLDPOS CURSOR
SETCURSOR [15 1]
TYPE "|      |
SETCURSOR :OLDPOS
END

TO BUILD.STATE :STATE
OP MAP [LINK :STATE ? (FIRST THING WORD :STATE ?)] THING :STATE
END

TO DETERMINE :MACHINE
LOCAL [NEWACCEPT ALLSTATES ALIASES TROUBLE TEMPNAMES NEWMOVES]
MAKE "NEWACCEPT ACCEPTPART :MACHINE
MAKE "ALLSTATES []
MAKE "ALIASES []
MAKE "TROUBLE "FALSE
MAKE "TEMPNAMES []
FOREACH MOVEPART :MACHINE [ARRANGE ?]
IF NOT :TROUBLE [FOREACH :TEMPNAMES [ERN ?] OP :MACHINE]
RESOLVE :ALLSTATES
MAKE "NEWMOVES REBUILD :ALLSTATES
FOREACH :TEMPNAMES [ERN ?]
OP LINK (STARTPART :MACHINE) :NEWMOVES :NEWACCEPT
END

TO FSM :MACHINE
CT
SETCURSOR [0 3]
FSM1 FIRST :MACHINE FIRST :MACHINE FIRST BF :MACHINE LAST :MACHINE
END

TO FSM1 :START :HERE :MOVES :ACCEPT
IFELSE MEMBERP :HERE :ACCEPT [ACCEPT] [REJECT]
FSM1 :START (FSMNEXT :START :HERE RC :MOVES) :MOVES :ACCEPT
END

TO FSMNEXT :START :HERE :INPUT :MOVES
BLANK
TYPE :INPUT
IF EQUALP :INPUT CHAR 13 [TYPE CHAR 10  OP :START]
CATCH "ERROR [OP LAST FIND [FSMTEST :HERE :INPUT ?] :MOVES]
OP -1
END

TO FSMTEST :HERE :INPUT :MOVE
OP AND (EQUALP :HERE FIRST :MOVE) (EQUALP :INPUT FIRST BF :MOVE)
END

TO GAME :WHICH
FSM THING WORD "MACH :WHICH
END

TO GETALIAS :LIST
CATCH "ERROR [OP FIRST FIND [EQUALP :LIST LAST ?] :ALIASES]
OP []
END

TO LINK :ONE :TWO :THREE
OP (LIST :ONE :TWO :THREE)
END

TO MACHINE :REGEXP
LOCAL "NEXTSTATE
MAKE "NEXTSTATE 0
OP OPTIMIZE DETERMINE NONDET :REGEXP
END

TO MAKESTATE :STATE
IF MEMBERP :STATE :ALLSTATES [STOP]
MAKE "ALLSTATES FPUT :STATE :ALLSTATES
TEMPMAKE :STATE []
END

TO MANY.MOVES :PARTMOVE :ACCEPT
FOREACH :ACCEPT [NEWMOVES SINGLE FPUT ? :PARTMOVE]
END

TO MAPND :EXPRS
OP MAP [NONDET ?] :EXPRS
END

TO MERGE :NEW :LIST
IF EMPTYP :LIST [OP FPUT :NEW []]
IF :NEW < FIRST :LIST [OP FPUT :NEW :LIST]
OP FPUT FIRST :LIST MERGE :NEW BF :LIST
END

TO MOVEPART :MACHINE
OP FIRST BF :MACHINE
END

TO NDCONCAT :EXPRS
OP REDUCE "STRING MAPND :EXPRS
END

TO NDLETTER :LETTER
LOCAL [FROM TO]
MAKE "FROM NEWSTATE
MAKE "TO NEWSTATE
OP LINK :FROM (SINGLE (LINK :FROM :LETTER :TO)) (SINGLE :TO)
END

TO NDMANY :REGEXP
OP NDMANY1 NONDET :REGEXP
END

TO NDMANY1 :MACHINE
LOCAL [START MOVES ACCEPT]
MAKE "START STARTPART :MACHINE
MAKE "MOVES MOVEPART :MACHINE
MAKE "ACCEPT ACCEPTPART :MACHINE
FOREACH :MOVES [IF EQUALP :START FIRST ? [MANY.MOVES BF ? :ACCEPT]]
OP LINK :START :MOVES (FPUT :START :ACCEPT)
END

TO NDOR :EXPRS
OP UNION NEWSTATE MAPND :EXPRS
END

TO NEWACCEPT :NEW
IF NOT MEMBERP :NEW :ACCEPT [MAKE "ACCEPT SE :NEW :ACCEPT]
END

TO NEWMOVES :NEW
MAKE "MOVES SE :NEW :MOVES
END

TO NEWSTATE
MAKE "NEXTSTATE :NEXTSTATE+1
OP :NEXTSTATE
END

TO NONDET :REGEXP
IF WORDP :REGEXP [OP NDLETTER :REGEXP]
IF EQUALP FIRST :REGEXP "OR [OP NDOR BF :REGEXP]
IF EQUALP FIRST :REGEXP "* [OP NDMANY LAST :REGEXP]
OP NDCONCAT :REGEXP
END

TO OPTIMIZE :MACHINE
LOCAL [START MOVES ACCEPT GOODSTATES GOODMOVES OLDMOVES]
MAKE "START STARTPART :MACHINE
MAKE "MOVES MOVEPART :MACHINE
MAKE "ACCEPT ACCEPTPART :MACHINE
MAKE "GOODSTATES SINGLE STARTPART :MACHINE
MAKE "GOODMOVES []
DO.UNTIL [MAKE "OLDMOVES :GOODMOVES ~
          MAKE "MOVES FILTER [OPTIMIZE2 ?] :MOVES] ~
         [EQUALP :OLDMOVES :GOODMOVES]
OP LINK :START :GOODMOVES (FILTER [MEMBERP ? :GOODSTATES] :ACCEPT)
END

TO OPTIMIZE2 :MOVE
IF NOT MEMBERP FIRST :MOVE :GOODSTATES [OP "TRUE]
MAKE "GOODMOVES FPUT :MOVE :GOODMOVES
IF NOT MEMBERP LAST :MOVE :GOODSTATES ~
   [MAKE "GOODSTATES FPUT LAST :MOVE :GOODSTATES]
OP "FALSE
END

TO REBUILD :STATELIST
OP MAP.SE [BUILD.STATE ?] :STATELIST
END

TO REJECT
LOCAL "OLDPOS
MAKE "OLDPOS CURSOR
SETCURSOR [15 1]
TYPE "REJECT
SETCURSOR :OLDPOS
END

TO RESOLVE :STATES
IF EMPTYP :STATES [STOP]
LOCAL "STATE
MAKE "STATE FIRST :STATES
RESOLVE SE (BF :STATES) ~
           (MAP.SE [RESOLVE.ARROW WORD :STATE ?] THING :STATE)
END

TO RESOLVE.ARROW :ARROW
LOCAL [DESTINATIONS ALIAS]
MAKE "DESTINATIONS THING :ARROW
IF EMPTYP BF :DESTINATIONS [OP []]
MAKE "ALIAS GETALIAS :DESTINATIONS
IF NOT EMPTYP :ALIAS [MAKE :ARROW SINGLE :ALIAS OP []]
MAKE "ALIAS NEWSTATE
MAKESTATE :ALIAS
MAKE :ARROW SINGLE :ALIAS
MAKE "ALIASES FPUT (LIST :ALIAS :DESTINATIONS) :ALIASES
FOREACH :DESTINATIONS [SETUPALIAS ?]
OP :ALIAS
END

TO SETA.INPUT :STATE :INPUT
FOREACH (THING WORD :STATE :INPUT) [ARRANGE LINK :ALIAS :INPUT ?]
END

TO SETUPALIAS :STATE
IF AND (MEMBERP :STATE :NEWACCEPT) (NOT MEMBERP :ALIAS :NEWACCEPT) ~
   [MAKE "NEWACCEPT FPUT :ALIAS :NEWACCEPT]
FOREACH THING :STATE [SETA.INPUT :STATE ?]
END

TO SINGLE :THING
OP (LIST :THING)
END

TO STARTPART :MACHINE
OP FIRST :MACHINE
END

TO STRING :MACHINE :OTHERS
LOCAL [START MOVES ACCEPT OTHERSTART OTHERMOVES OTHERACCEPT]
MAKE "START STARTPART :MACHINE
MAKE "MOVES MOVEPART :MACHINE
MAKE "ACCEPT ACCEPTPART :MACHINE
MAKE "OTHERSTART STARTPART :OTHERS
MAKE "OTHERMOVES MOVEPART :OTHERS
MAKE "OTHERACCEPT ACCEPTPART :OTHERS
OP LINK :START ~
        (SE :MOVES ~
            (STRING.SPLICE :ACCEPT :OTHERSTART :OTHERMOVES) ~
            :OTHERMOVES) ~
        (STRINGA :ACCEPT :OTHERSTART :OTHERACCEPT)
END

TO STRING.COPY :ACCEPT :OTHERSTART :MOVE
OP IFELSE EQUALP :OTHERSTART FIRST :MOVE [MAP [FPUT ? BF :MOVE] :ACCEPT] [[]]
END

TO STRING.SPLICE :ACCEPT :OTHERSTART :OTHERMOVES
OP MAP.SE [STRING.COPY :ACCEPT :OTHERSTART ?] :OTHERMOVES
END

TO STRINGA :ACCEPT :OTHERSTART :OTHERACCEPT
IF MEMBERP :OTHERSTART :OTHERACCEPT [OP SE :ACCEPT :OTHERACCEPT]
OP :OTHERACCEPT
END

TO TEMPMAKE :VAR :VAL
MAKE "TEMPNAMES FPUT :VAR :TEMPNAMES
MAKE :VAR :VAL
END

TO UNION :START :MACHINES
LOCAL [MOVES ACCEPT]
MAKE "MOVES []
MAKE "ACCEPT []
FOREACH :MACHINES [UNION1 ?]
OUTPUT LINK :START :MOVES :ACCEPT
END

TO UNION1 :MACHINE
NEWMOVES MOVEPART :MACHINE
NEWMOVES MAP [FPUT :START BF ?] ~
             FILTER [EQUALP (STARTPART :MACHINE) (FIRST ?)] MOVEPART :MACHINE
NEWACCEPT ACCEPTPART :MACHINE
IF MEMBERP (STARTPART :MACHINE) (ACCEPTPART :MACHINE) ~
   [NEWACCEPT :START]
END

MAKE "MACH1 [1 [[1 A 1] [1 B 1]] [1]]
MAKE "MACH10 [1 [[1 A 1] [1 B 1] [1 C 2] [2 A 3] [2 B 1] [3 A 1]] [1]]
MAKE "MACH2 [1 [[1 A 2] [1 B 2] [1 C 2] [2 A 1] [2 B 1] [2 C 1]] [1]]
MAKE "MACH3 [1 [[1 A 2] [2 B 3] [3 A 3] [3 B 3] [3 C 3]] [3]]
MAKE "MACH4 [1 [[1 A 2] [1 B 3] [1 C 4] [2 A 1] [3 B 1] [4 C 1]] [1]]
MAKE "MACH5 [1 [[1 A 2] [1 B 2] [1 C 2] [2 B 1]] [1]]
MAKE "MACH6 [1 [[1 A 2] [2 A 2] [2 B 2] [2 C 3] [3 A 2] [3 B 2] [3 C 3]] [3]]
MAKE "MACH7 [1 [[1 A 1] [1 B 1] [1 C 2] [2 C 1]] [1]]
MAKE "MACH8 [1 [[1 A 2] [1 B 1] [1 C 1] [2 A 1] [2 B 2] [2 C 2]] [1]]
MAKE "MACH9 [1 [[1 A 2] [1 B 1] [1 C 1] [2 A 2] [2 B 3] [2 C 1] [3 A 2] ~
                [3 B 1] [3 C 4] [4 A 2] [4 B 5] [4 C 1] [5 A 6] [5 B 1] ~
                [5 C 1] [6 A 6] [6 B 6] [6 C 6]] ~
             [6]]